home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / EGAVGA.SWG / 0169_Neat Wavey VGA Scoller.pas < prev    next >
Pascal/Delphi Source File  |  1995-03-03  |  4KB  |  110 lines
  1. {
  2. Hmmm, this is a small, but neat routine. Really something to post. I hope you
  3. like it. Made by Jeroen Bouwens, Holland. This routine is PD, Freeware and
  4. Smileware, which means bla..blabla...blablabla. Got it? See ya! :-)
  5.  
  6. O Yeah, I nearly forgot. It is a perspective scroller that comes right at you.
  7. }
  8. Uses Crt;
  9.  
  10. Var
  11.   I,J,XS,YS,TL,EP,AD,XT,YT,ZY         : Integer;
  12.   Alpha,Beta,Gamma,G,Tel              : Integer;
  13.   XX,YY,ZZ,BX,BY                      : Integer;
  14.   Exists                              : Boolean;
  15.   Tof,TSeg,SL,ArrayTel,Lof            : Word;
  16.   VX,VY,VZ                            : Real;
  17.   XT1,YT1,ZT1                         : Real;
  18.   Offsets                             : Array[0..160*50] Of Word;
  19.   Colors                              : Array[0..160*50] Of Byte;
  20.   Cosinus,Sinus                       : Array [0..360] of Real;
  21.   Tekst                               : String;
  22.  
  23. Procedure Rotate(Var X,Y,Z:Real;Alpha,Beta,Gamma:Integer);
  24. Var X1,X2,Y1,Y2,Z1,Z2 : Real;
  25. Begin
  26.   X1:=X;
  27.   Y1:=Cosinus[Alpha]*Y-Sinus[Alpha]*Z;
  28.   Z1:=Sinus[Alpha]*Y+Cosinus[Alpha]*Z;
  29.   X2:=Cosinus[Beta]*X1+Sinus[Beta]*Z1;
  30.   Y2:=Y1;
  31.   Z2:=Cosinus[Beta]*Z1-Sinus[Beta]*X1;
  32.   X:=Cosinus[Gamma]*X2-Sinus[Gamma]*Y2;
  33.   Y:=Sinus[Gamma]*X2+Cosinus[Gamma]*Y2;
  34.   Z:=Z2;
  35. End;{Rotate}
  36.  
  37. Procedure PrecalcPoints;
  38. Begin
  39.   For I:=0 To 360 Do Begin
  40.     Cosinus[I]:=Cos(I/57.29578);
  41.     Sinus[I]:=Sin(I/57.29578);
  42.   End;
  43.   G:=250;{Find some well working value for this (250 is fine for VZ=300) }
  44.   Alpha:=320; Beta:=310; Gamma:=330;{Change these for an other orientation of
  45.                                      the scroll}
  46.   VX:=0; VY:=0; VZ:=300;             {Don't make VZ 0 -> division by zero!!}
  47.   XX:=-160; YY:=-25; ZZ:=0;
  48.   For I:=1 To 160*50 do Begin
  49.     XT1:=XX; YT1:=YY; ZT1:=Cos(XX/10)*2+Sin(YY/5)*2; {Play with these!}
  50.     Colors[I]:=Round(ZT1*3+44);
  51.     Rotate(XT1,YT1,ZT1,Alpha,Beta,Gamma);
  52.     BX:=160+Round((XT1*G)/(ZT1+VZ));
  53.     BY:=100+Round((YT1*G*0.8333)/(ZT1+VZ));
  54.     Offsets[I]:=320*BY+BX;
  55.     Mem[$A000:Offsets[I]]:=15;
  56.     Inc(YY);
  57.     If YY>=24  Then Begin
  58.       YY:=-25;
  59.       XX:=XX+2;{Also change size of arrays:Offsets,Colors if you change this}
  60.       If XX>=159 Then Begin XX:=-160; YY:=-25; End;
  61.     End;
  62.   End;
  63.   FillChar(Mem[$A000:0],64000,0);
  64. End;
  65.  
  66. Begin
  67.   Asm Mov AX,$13; Int $10 End;
  68.   PrecalcPoints;
  69.   Tekst:='                    '+
  70.          'Well, this is an interesting routine (and it seems to work too '+
  71.          ':-)                    ';
  72.   TOf:=Ofs(Tekst); TSeg:=Seg(Tekst);
  73.   Tel:=0;
  74.   Repeat
  75.     For TL:=0 To 7 Do Begin
  76.       ArrayTel:=8*49+1;
  77.       For I:=1 To 19 Do Begin
  78.         SL:=Mem[TSeg:TOf+I+Tel];
  79.         LOf:=$FA6E+SL*8;
  80.         For XS:=0 To 7 Do Begin
  81.           For YS:=1 To 8 Do Begin
  82.             If (Mem[$F000:LOf] And (128 Shr XS))<>0 Then Begin
  83.               Mem[$A000:Offsets[ArrayTel-TL*49]]:=Colors[ArrayTel-TL*49];
  84.               Mem[$A000:Offsets[ArrayTel+1-TL*49]]:=Colors[ArrayTel-TL*49];
  85.               Mem[$A000:Offsets[ArrayTel+2-TL*49]]:=Colors[ArrayTel-TL*49];
  86.               Mem[$A000:Offsets[ArrayTel+3-TL*49]]:=Colors[ArrayTel-TL*49];
  87.               Mem[$A000:Offsets[ArrayTel+4-TL*49]]:=Colors[ArrayTel-TL*49];
  88.               Mem[$A000:Offsets[ArrayTel+5-TL*49]]:=Colors[ArrayTel-TL*49];
  89.             End Else Begin
  90.               Mem[$A000:Offsets[ArrayTel-TL*49]]:=0;
  91.               Mem[$A000:Offsets[ArrayTel+1-TL*49]]:=0;
  92.               Mem[$A000:Offsets[ArrayTel+2-TL*49]]:=0;
  93.               Mem[$A000:Offsets[ArrayTel+3-TL*49]]:=0;
  94.               Mem[$A000:Offsets[ArrayTel+4-TL*49]]:=0;
  95.               Mem[$A000:Offsets[ArrayTel+5-TL*49]]:=0;
  96.             End;
  97.             Inc(Lof);
  98.             Inc(ArrayTel,6);
  99.           End;
  100.           Dec(Lof,8);
  101.           Mem[$A000:Offsets[ArrayTel-TL*49]]:=0;
  102.           Inc(ArrayTel);
  103.         End;
  104.       End;
  105.     End;
  106.     Inc(Tel); If Tel>=Length(Tekst)-20 Then Tel:=0;
  107.   Until KeyPressed;
  108. End.
  109.  
  110.